home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1996 / MacHack 1996.toast / Presentations / Presentations ’94 / Timothy Knox / Pocket6.3 / Source / Dictionary.txt < prev    next >
Text File  |  1994-06-24  |  46KB  |  1,910 lines
  1. ; this file is: Dictionary.txt  --  forth words
  2. ; Tue Apr 05, 1988 21:59:10 load files >32K
  3. ; Thu Apr 07, 1988 15:59:46 nested loads
  4. ; Tue Apr 19, 1988 05:05:37 change "?BUTTON"
  5. ; Mon Apr 25, 1988 15:10:19 implement macros
  6. ; Tue Apr 26, 1988 19:49:49 optomizing "BACK"
  7. ; Thu Apr 28, 1988 23:09:23 fix ID.  better CONSTANT,2CONSTANT  add zero
  8. ; Fri Apr 29, 1988 09:43:49 add DLITERAL
  9. ; Sun May 01, 1988 04:24:52 make VARIABLE a macro
  10. ; Thu May 12, 1988 11:41:08 remove (PDO)  add 1- 2- & SP@  use slashFail
  11. ; Sun May 29, 1988 20:16:39 make CREATE shorter
  12. ; Tue May 31, 1988 14:27:25 make +MD a 4 byte macro  remove 2-
  13. ; Tue Jun 07, 1988 11:39:00 add R0@, S0@, RP@  redo STOD
  14. ; Sun Jun 23, 1991 09:33:00 add OPEN
  15. ; Thu Jan 13, 1992 19:05:00 Floating point math (rewrite 13Apr)
  16. ; Sun Feb 02, 1992 00:02:00 fix BACK
  17. ; Wed Apr 01, 1992 00:12:00 change STKCHK
  18. ; Tue Apr 14, 1992 22:48:00 rearrange to bring essentials toward front
  19. ; Sun Apr 19, 1992 23:24:00 split open into 2 parts, add AE: ;AE> ?GESTALT
  20. ; Sat Sep 19, 1992 17:05:00 fix FROLL in decimal places 15-19
  21. ; Fri Jan 22, 1993 19:28:00 fix TYPE
  22. ; Mon Apr 19, 1993 22:58:00 move ?BUTTON and FLITERAL
  23. ; Thu May 06, 1993 23:04:00 fix +LOOP and QUIT
  24. ; Sat May 29, 1993 15:20:00 fix TYPE (again)
  25. ; Tue Jun 01, 1993 23:25:00 add WARM, DEPTH
  26. ; Wed Jun 09, 1993 20:17:00 change IMMEDIATE,PAGE,doLoad,header,dictstart
  27.  
  28. DictStart:
  29.     DC.L    0            ; End of dictionary search
  30.     
  31.     DC.B    128+1,13,0,0        ; "{cr}" ( -- ) goto restart
  32.     DC.W    dictstart-base
  33. CRet:    MOVE.L    rzero-base(bp),rs    ; reset return stack
  34.     JMP    Restart-base(BP)    ; and jump
  35.     
  36.     DC.B    128+1,0,0,0        ; "{null}" ( -- ) same as cret
  37.     DC.W    cret-theLink
  38. NRet:    BRA.S    cret
  39.  
  40.     DC.B    128+1,'\',0,0        ; "\" ( -- ) backslash
  41.     DC.W    nret-theLink        ;  line ending comment
  42. Backsl:    bra.s    cret
  43.  
  44.     DC.B    9,'?TE'            ; "?terminal" ( -- flag )
  45.     DC.W    backsl -theLink        ;  was a key pressed?
  46. QTerm:    JSR    NextEvent-base(BP)
  47.     CLR    -(PS)
  48.     TST    kflag-base(BP)
  49.     BEQ.S    @0
  50.     SUBQ    #1,(PS)
  51.     @0:    RTS
  52.  
  53.     DC.B    3,'KEY'            ; "key" ( -- ascii )
  54.     DC.W    qterm-theLink        ;   wait for a key press
  55. Key:    BSR.S    Curs
  56.     @0:    JSR    NextEvent-base(BP)    ; set kflag if a key is pressed
  57.     TST    KFlag-base(BP)        ; ( among other things... )
  58.     BEQ.S    @0
  59.     BSR.S    NoCurs
  60.     MOVE    KFlag-base(BP),-(PS)
  61.     RTS
  62.  
  63. NoCurs:    MOVE    #10,-(SP)        ; SrcXor mode
  64.     _PenMode
  65.   Curs:    clr.l    -(sp)
  66.     addq.l    #6,(sp)
  67.     _Move
  68.     MOVE.L    #$0000FFFA,-(SP)    ; draw 6 pixels to the left
  69.     _Line
  70.     _PenNormal
  71.     RTS
  72.  
  73.     DC.B    6,'?ST'            ; "?stack" ( ? -- )
  74.     DC.W    key-theLink
  75. StkChk: CMPA.L    Szero-base(BP),PS
  76.     BGT.S    @0
  77.     RTS
  78.     @0:    JSR    space-base(BP)
  79.       MOVEQ    #42,D0            ; print *  if stack underflow
  80.     JSR    EmitCode-base(BP)
  81.     BRA.S    huh
  82.  
  83.     DC.B    7,'?BU'            ; "?button" ( -- flag )
  84.     DC.W    StkChk-theLink
  85. QButton:
  86.     CLR    -(SP)
  87.     _Button
  88.     MOVE    (SP)+,-(PS)
  89.     BEQ.S    @0
  90.     SUBI    #257,(PS)
  91.     @0:    RTS
  92.  
  93.     DC.B    6,'WHA'            ; "whazat" ( -- )
  94.     DC.W    QButton-theLink
  95. WhaZat:    jsr    dwrd-base(bp)        ; push token address
  96.     BRA.S    huh
  97.  
  98.     DC.B    5,'ABO'            ; "abort" ( -- )
  99.     DC.W    whazat-theLink
  100. huh:    MOVE.L    Szero-base(BP),PS    ; reset stack pointer < moved 5/93
  101.     MOVEQ    #63,D0            ; send ?
  102.     JSR    EmitCode-base(BP)
  103.     BSR.S    crlf
  104.     BRA.S    fin
  105.     
  106.     DC.B    4,'QUI'            ; "quit" ( -- )
  107.     DC.W    huh-theLink        ;    restart the interpreter loop
  108. fin:    JSR    emptyfs-base(BP)    ; clear pending loads
  109.     CLR.L    fcolon-base(BP)        ; clear compiling flag
  110.     BSET.B    #7,fint-base(BP)    ; reset to keyboard input
  111.     JMP    cret-base(BP)
  112.  
  113.     DC.B    2,'CR',0        ; "cr" ( -- ) output CR to screen
  114.     DC.W    fin-theLink
  115. CRLF:    JMP    doCR-Base(BP)        ; part of emit
  116.  
  117.     DC.B    3,'.OK'            ; ".ok" ( -- )
  118.     DC.W    crlf-theLink
  119. Prompt:    JSR    space-base(BP)        ; send space
  120.     MOVEQ    #111,D0
  121.     JSR    EmitCode-base(BP)    ; send "o"
  122.     MOVEQ    #107,D0
  123.     JSR    EmitCode-base(BP)    ; send "k"
  124.     JMP    space-base(BP)        ; send another space & return
  125.  
  126.     DC.B    5,'UPP'            ; "upper" ( addr -- )
  127.     DC.W    prompt-theLink        ;   change a string to upper case
  128. Upper:    MOVE    (PS)+,D0
  129.     LEA    0(BP,D0.W),A0        ; get the address
  130.     CLR    D0
  131.     MOVE.B    (A0),D0            ; get count
  132.     @0:    CMPI.B    #$60,0(A0,D0.W)        ; BEGIN  get char at addr + count
  133.     BLE.S    @1            ;   char > 'a'
  134.     CMPI.B    #$7B,0(A0,D0.W)        ;   char < 'z'
  135.     BGE.S    @1            ;   AND IF
  136.     SUBI.B    #32,0(A0,D0.W)        ;     char 32 - -> char THEN
  137.     @1:    DBRA    D0,@0            ; count 1- -> count count NOT UNTIL
  138.     RTS
  139.  
  140.     DC.B    5,'TOK'            ; "token" ( -- ) put a token
  141.     DC.W    upper-theLink        ;   from (IS) into (DP),
  142. Token:    MOVE    #32,-(PS)        ;   which is at end of dict.
  143.     BSR.S    word
  144.     JSR    here-base(BP)        ; Fri Apr 29, 1988 00:27:23 simpl
  145.     BRA.S    Upper
  146.  
  147.     DC.B    6,'HEA'            ; "header" ( -- ) create a header
  148.     DC.W    token-theLink        ;   for the current word at DP
  149. Header:    MOVE    Dict,4(DP)        ; link header to dictionary
  150.     MOVE.L    DP,Dict            ; update DICT
  151.     SUB.L    BP,Dict            ; make it a rel.addr
  152.     addq.l    #6,dp            ; update DP
  153.     RTS
  154.  
  155.     DC.B    4,'WOR'            ; "word" ( c -- ) c is delimiter
  156.     DC.W    header-theLink        ;   get chars from (IS) into HERE
  157. Word:    MOVE.L    D4,-(SP)        ; preserve the register
  158.     MOVE    (PS)+,D4        ; get delimiter character
  159.     CLR.L    (DP)            ; clear token buffer
  160.     CLR.L    D1            ; clear count
  161.     @0:    MOVE.B    (IS)+,D0        ; get characters until delimiter
  162.     CMP.B    D4,D0
  163.     BEQ.S    @1
  164.     MOVE.B    D0,1(DP,D1)        ; place in token buffer
  165.     ADDQ.B    #1,D1            ; increment count
  166.     BRA.S    @0
  167.     @1:    MOVE.B    D1,(DP)            ; put count in 1st byte of buffer
  168.     BEQ.S    @0            ; if count is 0 repeat
  169.     MOVE.L    (SP)+,D4        ; restore the register
  170.     RTS
  171.  
  172.     DC.B    1,'''',0,0        ; "'" ( -- rel.addr ) return the
  173.     DC.W    word-theLink        ;  cfa of the following word
  174. Tick:    bsr.s    token            ; get the next word
  175.     MOVE    Dict,-(PS)        ; push dict ptr to parmstk
  176.     bsr.s    search            ; lookup the current token
  177.     TST    (PS)+
  178.     BEQ    Whazat
  179.     RTS
  180.  
  181.     DC.B    6,'SEA'            ; "search" ( addr -- cfa t  OR  f )
  182.     DC.W    tick-theLink
  183. Search:    MOVE.L    (DP),D1            ; put token "stem" in D1
  184.     MOVE    (PS),D0            ; use A0 as search pointer
  185.     CLR    fmacro-base(BP)        ; clear the macro flag
  186.     @0:    LEA    0(BP,D0.W),A0        ; DO
  187.     TST    (A0)            ;   IF DictStart  exit NOFIND
  188.     BEQ.S    nofind
  189.     CMP.L    (A0),D1            ;   compare word to candidate
  190.     BEQ.S    find            ;   IF found, exit FIND
  191.     BCHG    #31,D1            ;   set immediate bit
  192.     CMP.L    (A0),D1            ;   compare to "immediate" version
  193.     BEQ.S    ifind            ;   IF found, exit IFIND
  194.     BCHG    #31,D1            ;   reset immediate bit
  195.     BCHG    #30,D1            ;   set macro bit
  196.     CMP.L    (A0),D1            ;   compare to "macro" version
  197.     BEQ.S    mfind            ;   IF found, exit MFIND
  198.     BCHG    #30,D1            ;   reset macro bit
  199.     MOVE    4(A0),D0        ;   get link rel.address
  200.     BRA.S    @0            ; LOOP
  201. nofind:    CLR    (PS)            ; push fail flag
  202.     RTS
  203.  mfind:    BSET.B    #7,fmacro-base(BP)    ; set macro flag
  204.     BRA.S    find
  205.  ifind:    BSET.B    #7,fimmed-base(BP)    ; set immediate flag
  206.   find:    LEA    6(A0),A0        ; cfa is at 6+nfa
  207.     SUBA.L    BP,A0            ; convert code address to relative
  208.     MOVE    A0,(PS)            ; push code rel address
  209.     MOVE    #-1,-(PS)        ; push success flag
  210.     RTS
  211.  
  212.     DC.B    6,'NUM'            ; "number" ( addr -- n t  OR  f )
  213.     DC.W    search-theLink
  214. Number:    MOVE.L    D4,-(SP)        ; save the register
  215.     CLR.L    D1
  216.     CLR.L    D4            ; clear conversion register
  217.     MOVE    (PS)+,D0        ; get token addr in D0
  218.     LEA    0(BP,D0.W),A0        ; put abs.addr in A0
  219.     CMPI.B    #'-',1(A0)        ; is it negative?
  220.     BNE.S    @0            ; IF yes
  221.     BSET.B    #7,fneg-base(BP)    ;     set negative flag
  222.     MOVE.B    #'0',1(A0)        ;     change dash to zero
  223.     @0:    CLR.L    D0            ; THEN
  224.     MOVE.B    (A0)+,D1        ; get digit count
  225.  digit:    MOVE.B    (A0)+,D0        ; BEGIN get next digit
  226.     SUBI.B    #48,D0            ;     strip ASCII prefix
  227.     BLT.S    @2            ;     if digit too small, FAIL
  228.     CMP    #10,D0            ;     if digit > 9
  229.     BLT.S    @1            ;     adjust for radix>10 values
  230.     SUBI.B    #7,D0            ;     and test again
  231.     CMP    #10,D0
  232.     BLT.S    @2
  233.     @1:    CMP    NBase-base(BP),D0    ;     if base < digit
  234.     BGE.S    @2            ;     FAIL
  235.     MULU    NBase-base(BP),D4    ;     multiply value by base
  236.     ADD    D0,D4            ;     add current digit
  237.     SUBQ.B    #1,D1            ;     decrement count
  238.     BNE.S    digit            ; UNTIL no digits remain
  239.         BCLR    #7,fneg-base(BP)    ; test and clear negative flag
  240.     BEQ.S    @0            ; if set
  241.     NEG    D4            ; Negate it
  242.     @0:    MOVE    D4,-(PS)        ; push number
  243.     MOVE    #-1,-(PS)        ; push success flag
  244.     BRA.S    @3
  245.     @2:    CLR    -(PS)            ; push fail flag
  246.     @3:    MOVE.L    (SP)+,D4        ; restore the register
  247.     RTS
  248.  
  249.     DC.B    7,'FNU'            ; FNUMBER ( dabs.addr -- f )
  250.     DC.W    number-theLink        ; convert string at dabs.addr to fp
  251. fnum:    MOVE.L    (PS)+,-(RS)
  252.     MOVE    #1,-(PS)
  253.     PEA    (PS)
  254.     PEA    $14(DP)
  255.     CLR    -(PS)
  256.     PEA    (PS)
  257.     FPSTR2DEC
  258.     ADDQ.L    #4,PS
  259.     CMPI    #$054E,24(DP)        ; check for NAN##
  260.     BNE.S    @0
  261. ;    move    whaError-base(bp),d0    ; vector error 6/1/93
  262. ;    jmp    0(bp,d0.w)
  263.     JMP    whazat-base(BP)
  264.     @0:    PEA    $14(DP)
  265.     SUBQ.L    #6,PS
  266.     SUBQ.L    #4,PS
  267.     PEA    (PS)
  268.     FDEC2X
  269.     RTS
  270.     
  271.     DC.B    7,'EXE'            ; "execute" ( cfa -- ) do a routine
  272.     DC.W    fnum-theLink        ;    whose cfa is on the stack
  273. EXECUTE    MOVE    (PS)+,D0        ; pop code address
  274.     JMP    0(BP,D0.W)        ; execute & return
  275.  
  276.     DC.B    8,'MCO'            ; "mcompile" ( cfa -- ) 
  277.     DC.W    Execute-theLink        ; compile subroutine bodies inline 
  278. MComp:    MOVE    (PS)+,D0
  279.     LEA    0(BP,D0.W),A0        ; addr of word
  280.     @0:    MOVE    (A0)+,D0
  281.     CMPI    #$4E75,D0        ; if its an RTS your done
  282.     BEQ.S    @1
  283.     MOVE    D0,(A2)+        ; if not, compile it
  284.     BRA.S    @0            ; do next word
  285.     @1:    RTS
  286.     
  287.     DC.B    128+9,'[CO'        ; "[compile]" ( -- )  compile
  288.     DC.W    mcomp-theLink        ;   the next immediate word
  289. bCompile:
  290.     JSR    tick-base(BP)        ; get the cfa of the next word
  291.     bra.s    compile            ;  and compile a JSR to it
  292.     
  293.     DC.B    7,'COM'            ; "compile" ( cfa -- ) compile a 
  294.     DC.W    bcompile-theLink        ;    call to the cfa on the stack
  295. COMPILE    MOVE    #$04EAB,(DP)+        ; compile "JSR d(A3)"
  296.     BRA.S    Comma            ; compile displacement value
  297.  
  298.     DC.B    9,'IMM'            ; "immediate" ( -- ) make the last
  299.     DC.W    compile-theLink        ;   word defined immediate
  300. IMMED    BSET    #7,0(BP,Dict.W)        ; set immediate bit of most recent word
  301.     RTS
  302.  
  303.     DC.B    5,'MAC'            ; "macro" ( -- ) make the last
  304.     DC.W    immed-theLink        ;   word defined an inline macro
  305. marco:    BSET    #6,0(BP,Dict.W)        ; set macro bit of most recent word
  306.     RTS
  307.  
  308.     DC.B    1,':',0,0        ; ":" ( -- ) make a header for a 
  309.     DC.W    marco-theLink        ;   word definition
  310. COLON    JSR    token-Base(BP)        ; make header
  311.     JSR    header-base(BP)
  312.     BRA.S    rbrack            ; enter compile mode
  313.     
  314.     DC.B    129,']',0,0        ; "]" ( -- ) enter compile mode
  315.     DC.W    colon-theLink
  316. rBrack:    BSET    #7,fcolon-base(BP)    ; set colon flag
  317.     RTS
  318.  
  319.     DC.B    129,';',0,0        ; ";" ( -- ) end a word definition
  320.     DC.W    rBrack-theLink
  321. SEMI    MOVE    #$4E75,(DP)+        ; compile "RTS"
  322.     BRA.S    lbrack
  323.     
  324.     DC.B    129,'[',0,0        ; "[" ( -- ) leave compile mode
  325.     DC.W    semi-theLink
  326. lBrack:    CLR.B    fcolon-base(BP)        ; clear colon flag
  327.     RTS
  328.     
  329.     DC.B    7,'LIT'            ; "literal" compiling: ( n -- )
  330.     DC.W    lBrack-theLink        ;   executing: ( -- n )
  331. LITERAL    MOVE    #$03D3C,(DP)+        ; compile move #xxxx,-(PS)
  332.     BRA.S    Comma            ; compile constant
  333.  
  334.     DC.B    64+1,',',0,0        ; "," ( n -- )
  335.     DC.W    literal-theLink
  336. COMMA    MOVE    (PS)+,(DP)+        ; pop number to dictionary
  337.     RTS
  338.  
  339.     DC.B    8,'FLI'        ; FLITERAL ( comp: n5 n4 n3 n2 n1 -- |exec: -- n5 n4 n3 n2 n1 )
  340.     DC.W    comma-theLink
  341. flit:    MOVE    (PS),D0
  342.     MOVE    2(PS),D1
  343.     MOVE    8(PS),(PS)
  344.     MOVE    6(PS),2(PS)
  345.     MOVE    D0,8(PS)
  346.     MOVE    D1,6(PS)
  347.     MOVEQ    #4,D0
  348.     @0:    bsr.s    literal
  349.     DBRA    D0,@0
  350.     RTS
  351.  
  352.     DC.B    128+2,',$',0        ; ",$" ( -- )
  353.     DC.W    flit-theLink        ; compile a hex number from input
  354. CommaH:    MOVE    NBase-base(BP),-(RS)
  355.     MOVE    #$10,nbase-base(BP)
  356.     JSR    token-base(BP)
  357.     BSR.S    here
  358.     JSR    number-base(BP)
  359.     MOVE    (RS)+,nbase-base(BP)
  360.     TST    (PS)+
  361.     BEQ    whazat
  362.     BRA.S    comma
  363.  
  364.     DC.B    4,'HER'            ; "here" ( -- addr )
  365.     DC.W    commah-theLink        ;   rel.addr of compile point
  366. here:     MOVE.L    DP,-(PS)
  367.     BRA.S    torel
  368.  
  369.     DC.B    8,'DLI'            ; "dliteral" compiling: ( d -- )
  370.     DC.W    here-theLink        ;   executing: ( -- d )
  371. DLit:    MOVE    #$2D3C,(DP)+        ; compile move.l #xxxx,-(PS)
  372.     MOVE.L    (PS)+,(DP)+        ; compile double number
  373.     RTS
  374.  
  375.     DC.B    4,'>RE'            ; ">rel" (to-rel) ( rel.uu) (rel.ah)
  376.     DC.W    dlit-theLink        ; ( daddr32 -- addr16 )
  377. toRel:    MOVE.L    (PS)+,D0        ; get the Daddr32 from stack
  378.     SUB.L    BP,D0            ; get difference from base addr
  379.     MOVE    D0,-(PS)        ; push the 16 bit part of it
  380.     RTS
  381.  
  382.     DC.B    5,'COU'            ; "count" ( addr -- addr+1 length )
  383.     DC.W    torel-theLink
  384. Count:    CLR    D1
  385.     MOVE    (PS),D0
  386.     MOVE.B    0(BP,D0.W),D1
  387.     ADDQ    #1,(PS)
  388.     MOVE    D1,-(PS)
  389.     RTS
  390.  
  391.     DC.B    64+3,'+MD'        ; "+MD" ( offset -- addr )
  392.     DC.W    count-theLink
  393. MacDat:    ADDI    #theWindow-base,(PS)    ; add data addr to stacked offset
  394.     RTS
  395.     
  396.     DC.B    4,'PAG'            ; "page" ( -- )
  397.     DC.W    macdat-theLink        ; clear the window
  398. Page:    PEA    WContRect-base(BP)    ; The visable part of the window.
  399.     _EraseRect
  400.     MOVE.l    #$90001,-(SP)
  401.     _MoveTo                ; set pen position to home (1,9)
  402.     _PenNormal            ; 1X1, black, patcopy
  403.     MOVE.l    #$40000,-(SP)
  404.     _TextFont            ; Monaco
  405.     _TextFace            ; plain text
  406.     MOVE.l    #$90000,-(SP)
  407.     _TextSize            ; 9 point
  408.     _TextMode            ; srcCopy
  409.     RTS
  410.  
  411.     DC.B    4,'BEE'            ; "beep" ( -- )
  412.     DC.W    page-theLink
  413. Beep:    MOVE.W    #3,-(SP)
  414.     _SysBeep
  415.     RTS
  416.  
  417.     DC.B    64+3,'MON'        ; "mon" ( -- ) execute _Debugger
  418.     DC.W    beep-theLink
  419. Mon:    _DeBugger
  420.     RTS
  421.  
  422.     DC.B    3,'BYE'            ; "bye" ( -- ) set quit flag
  423.     DC.W    mon-theLink
  424. Bye:    ADDQ    #1,doneFlag-base(BP)
  425.     RTS
  426.  
  427. TexD:    DC.W    'TEXT'
  428.  
  429.     DC.B    4,'OPE'            ; "open" ( -- vrefnum )
  430.     DC.W    bye-theLink
  431. Open:    MOVE.L    #$4B0037,-(SP)        ; point: 75,55
  432.     CLR.L    -(SP)            ; no prompt
  433.     CLR.L    -(SP)            ; no filter
  434.     MOVE    #1,-(SP)        ; 1 type
  435.     PEA    texd-base(BP)
  436.     CLR.L    -(SP)            ; no hook
  437.     PEA    (A2)            ; put sfreply at here
  438.     MOVE    #2,-(SP)
  439.     _Pack3                ; _sfreply
  440.     TST    (A2)            ; check 'good' field
  441.     BEQ.S    beep            ; beep if cancel
  442.  
  443.     MOVE    6(A2),-(PS)        ; hold the vrefnum on stack        ***
  444.     CLR    D0
  445.     @0:    MOVE.L    10(A2,D0.W),40(A2,D0.W)    ; move the file name to PAD
  446.     ADDQ    #4,D0
  447.     CMP    #32,D0
  448.     BLE.S    @0
  449.     ADDQ    #1,openFlag-base(BP)
  450.     RTS
  451.  
  452.     DC.B    3,'-->'            ; "-->" ( -- )
  453.     DC.W    open-theLink
  454. Load:    JSR    token-base(BP)        ; put filename string at HERE
  455.     CLR    -(PS)            ; set vrefnum to 0 (path is specified)
  456.     BRA.S    load1
  457.     
  458. doLoad:
  459.     lea    40(a2),a0        ; Move the file name from PAD to HERE
  460.     move.l    a2,a1
  461.     moveq    #32,d0
  462.     _blockmove
  463.  
  464. ;    CLR    D0            ; Move the file name from PAD to HERE
  465. ;   @0:    MOVE.L    40(A2,D0.W),0(A2,D0.W)    ; 
  466. ;    ADDQ    #4,D0            ; 
  467. ;    CMP    #32,D0            ; 
  468. ;    BLE.S    @0
  469.  
  470.  load1:    MOVE    fsptr-base(BP),D0    ; get file stack pointer
  471.     BMI.S    @1            ;  ... save the offset into text ...
  472.     LEA    fofsets-base(BP),A0    ;  ... at fofsets+fspointer
  473.     MOVE.L    TextO-base(BP),0(A0,D0.W)
  474.     LEA    fends-base(BP),A0    ;  TextE at fends+fspointer
  475.     MOVE.L    TextE-base(BP),0(A0,D0.W)
  476.     @1:    ADDQ    #4,fsptr-base(BP)    ; increment the file stack pointer
  477.     
  478.     MOVE.L    #80,D0            ; create an 80 byte block for
  479.     _NewPtr.CLEAR            ; make the file control buffer
  480.     MOVE.L    A0,A4            ; save it for later
  481.     MOVE.B    #1,27(A0)        ; set read only permission
  482.     MOVE.L    DP,18(A0)        ; set name pointer
  483.     MOVE    (PS)+,22(A0)        ; set vrefnum (working directory)
  484.     _HOpen
  485.     TST    16(A0)
  486.     BNE.S    derror
  487.     _GetEOF                ; get ...
  488.     MOVE.L    28(A0),36(A0)        ;  ... and set ...
  489.     MOVE.L    28(A0),-(PS)        ;  ... and hold the file size
  490.     
  491.     MOVE.L    (PS),D0            ; set block size = file size
  492.     _NewHandle
  493.     BMI.S    derror
  494.     
  495.     MOVE    fsptr-base(BP),D0    ; get file stack pointer
  496.     LEA    fstack-base(BP),A1    ; file stack address
  497.     MOVE.L    A0,0(A1,D0.W)        ; stash the handle at fstack+(fsptr)
  498.     _HLock
  499.     
  500.     MOVE.L    (A0),A0            ; get start addr of block
  501.     MOVE.L    A0,TextO-base(BP)    ; set buffer start
  502.     MOVE.L    A0,D0            ; set buffer end ...
  503.     ADD.L    (PS)+,D0
  504.     MOVE.L    D0,TextE-base(BP)    ;  ... to start + size
  505.     
  506.     MOVE.L    A4,A0            ; retrieve fcb pointer
  507.     MOVE.L    TextO-base(BP),32(A0)    ; set read buffer addr in fcb
  508.     _Read                ; read data from file ...
  509.     TST    16(A0)            ; ... to scrap buffer
  510.     BNE.S    derror
  511.     _Close
  512.     _DisposPtr
  513.     JMP    go-base(BP)        ; interpret scrap buffer
  514.  
  515. DError:    MOVE    16(A0),-(PS)
  516.     _Close
  517.     _DisposPtr
  518.     JSR    pquote-base(BP)
  519.     DC.B    5,'Disk:'        ; print the error messsage
  520.    der:    JSR    dot-base(BP)        ; report the error number
  521.   der1:    JMP    huh-base(BP)
  522.  
  523. ;        DC.B    3,'REZ'        ; Return the handle to a resource
  524. ;        DC.W    load-theLink    ; ( ID type -- handle t or f )
  525. ;    Rez:    CLR.L    -(SP)
  526. ;        MOVE.L    (PS)+,-(SP)
  527. ;        MOVE    (PS)+,-(SP)
  528. ;        _GetResource
  529. ;        MOVE.L    (SP)+,D0    ; nil handle means error
  530. ;        BEQ.S    gser2
  531. ;        MOVE.L    D0,-(PS)
  532. ;        MOVE    #-1,-(PS)
  533. ;        RTS
  534.  
  535.     DC.B    8,'?GE'        ; "?GESTALT"
  536.     DC.W    load-theLink    ; ( d.selector -- d.response true or false )
  537. QGestalt:        ; false if 64K ROM or no _Gestalt or bad selector
  538.     ; check for 64K ROM
  539.     MOVE    #$A86E,D0        ; _InitGraf
  540.     _GetTrapAddress.newTool
  541.     MOVE.L    A0,D1
  542.     MOVE    #$AA6E,D0        ; _InitGraf AND $200
  543.     _GetTrapAddress.newTool
  544.     CMP.L    A0,D1
  545.     BEQ.S    gser1            ; 64KROM
  546.  
  547.     ; Check for gestalt
  548.     MOVE.W    #$A89F,D0        ; _Unimplemented
  549.     _GetTrapAddress.newTool        ; NGetTrapAddress
  550.     MOVE.L    A0,D1
  551.     MOVE.W    #$A1AD,D0        ; _Gestalt
  552.     _GetTrapAddress.newOS        ; NGetTrapAddress
  553.     CMP.L    A0,D1
  554.     BEQ.S    gser1            ; no gestalt
  555.  
  556.     ; run gestalt
  557.     MOVE.L    (PS)+,D0
  558.     _Gestalt
  559.     BNE.S    gser2
  560.     MOVE.L    A0,-(PS)        ; return the result  ... and ...
  561.     MOVE    #-1,-(PS)        ; return true
  562.  gsret:    RTS
  563.  
  564.  gser1:    ADDQ.L    #4,PS            ; gestalt error
  565.  gser2:    CLR    -(PS)            ; return false
  566.     RTS
  567.  
  568.     DC.B    128+2,',S',0        ; ",S" compile a dnumber from ascii
  569.     DC.W    qgestalt-theLink    ; NOTE: 1 and only 1 space seperates
  570. CommaS:    MOVE.L    A2,A0
  571.     MOVEQ    #4,D0
  572.     @0:    MOVE.B    (IS)+,(A0)+
  573.     DBRA    D0,@0
  574.     MOVE.L    (A2),-(PS)
  575.  
  576.     TST.B    fcolon-base(BP)
  577.     BEQ.S    gsret
  578.     JMP    dlit-base(BP)
  579.  
  580.     DC.B    64+9,'INT'        ; "interpret"
  581.     DC.W    commas-theLink
  582. Interp:    JMP    main-base(BP)
  583.     RTS            ; <- gotta have this for mcompile
  584.  
  585.     DC.B    4,'ROO'            ; "room" ( -- bytes )
  586.     DC.W    interp-theLink
  587. Room:    MOVE.L    A3,A0
  588.     _RecoverHandle            ; use handle rather than pointer
  589.     _GetHandleSize
  590.     MOVE.L    A3,A0            ; Bottom
  591.     ADDA.L    D0,A0            ;  +  block size ...
  592.     SUBA.L    A2,A0            ;  -  end of dictionary
  593.     MOVE    A0,-(PS)        ;  =  unused dictionary space
  594.     RTS
  595.  
  596. CSave:    CLR    -(SP)            ; Room for which item number.
  597.     MOVE    #259,-(SP)        ; Resource ID of ALRT
  598.     CLR.L    -(SP)
  599.     _Alert                ; About Item
  600.     SUBQ    #1,(SP)+        ; check which item dismissed.
  601.     BEQ.S    save            ; save if 'ok'
  602.     RTS
  603.  
  604.     DC.B    4,'SAV'            ; "save" ( -- ) save the dictionary
  605.     DC.W    room-theLink
  606. Save:    JSR    here-base(BP)
  607.     MOVE    (PS)+,freePt-base(BP)    ; save current DP
  608.     MOVE    Dict,DictPt-base(BP)    ; save current DictPt
  609.     BSR.S    room
  610.     MOVE    (PS),freesz-base(BP)    ; save current headroom
  611.     BSR.S    negate
  612.     BSR.S    grow            ; reduce headroom to 4 bytes
  613.     move.l    a3,A0            ; bottom
  614.     _RecoverHandle            ; get DICT's handle
  615.     CLR    -(SP)
  616.     MOVE.L    A0,-(SP)        ; push 2, 1 for each operation
  617.     MOVE.L    A0,-(SP)
  618.     _ChangedResource
  619.     _HomeResFile
  620.     _UpdateResFile            ; write out the DICT
  621.     MOVE    freesz-base(BP),-(PS)
  622. Grow:    JSR    here-base(BP)
  623.     MOVE    (PS)+,D1        ; hold rel DP in D1
  624.     MOVE.L    IS,-(PS)
  625.     JSR    torel-base(BP)
  626.     MOVE    (PS)+,D2
  627.     MOVE.L    (RS),-(PS)
  628.     JSR    torel-base(BP)
  629.     JSR    swapp-base(BP)
  630.     MOVEA.L    expand-base(BP),A0
  631.     JMP    (A0)            ; JSR won't return here
  632.  
  633.     DC.B    4,'>AB'            ; ">abs" (to-abs)
  634.     DC.W    save-theLink        ; ( addr16 -- daddr32 )
  635. toAbs:    CLR.L    D0
  636.     MOVE    (PS)+,D0        ; pop rel addr
  637.     LEA    0(BP,D0.W),A0        ; calc as offset to base ...
  638.     MOVE.L    A0,-(PS)        ; ...  and push
  639.     RTS
  640.  
  641.     DC.B    64+6,'NEG'        ; "negate" ( n -- -n )
  642.     DC.W    toabs-theLink
  643. negate:    NEG    (PS)
  644.     RTS
  645.  
  646.     DC.B    5,'SPA'            ; "space" ( -- ) emit a space
  647.     DC.W    negate-theLink
  648. space:    MOVE.L    #32,D0
  649.     bra.s    emitcode
  650.  
  651.     DC.B    4,'TYP'            ; "type" ( rel.addr len -- )
  652.     DC.W    space-theLink        ;  emit len characters from rel.addr
  653. Type:    MOVEM.L    D3/D4,-(SP)        ; don't trash registers!
  654.     MOVE    (PS)+,D3        ; get character count
  655.     SUBQ    #1,D3
  656.     MOVE    (PS)+,D4        ; get string relative address
  657.     @0:    MOVE.B    0(BP,D4.W),D0        ; get character byte
  658.     bsr.s    emitcode        ; print character byte
  659.     ADDQ    #1,D4
  660.     DBRA    D3,@0
  661.     MOVEM.L    (SP)+,D3/D4        ; restore registers
  662.     rts
  663.  
  664. pQuote:    ;   runtime part of ."
  665.     MOVE.L    (RS),-(PS)        ; push the addr of the string
  666.     JSR    torel-base(BP)
  667.     ADDQ    #1,(PS)            ; skip the length byte
  668.     MOVE.L    (RS),A0
  669.     CLR.L    D0            ; clear the character count
  670.     MOVE.B    (A0),D0            ; get the length
  671.     MOVE    D0,-(PS)        ; push it
  672.     ADDQ    #2,D0
  673.     ANDI    #$FFFE,D0        ; be sure its even
  674.     ADD.L    D0,(RS)            ; skip over string upon return
  675.     bra.s    type            ; type the string
  676.     
  677.     DC.B    4,'EMI'            ; "emit" ( n -- ) send the ascii
  678.     DC.W    type-theLink        ;                 to the terminal
  679. Emit:    MOVE    (PS)+,D0
  680.   EmitCode:                ; Emit contents of D0
  681.     CMP.B    #13,D0            ; is it a <cr>
  682.     BEQ.S    doCR
  683.     CMP.B    #8,D0            ; is it a <del>?
  684.     BEQ.S    doDEL
  685.     ANDI    #$FF,D0
  686.     MOVE    D0,-(A7)
  687.     _DrawChar
  688.     BSR.S    penh
  689.     MOVE    WContRect+6-base(BP),D0    ; right coord of WContRect
  690.     CMP    D0,D1            ; is the position beyond the edge
  691.     BLS.S    emitr            ; no
  692.     
  693.   doCR:    PEA    Scratch-base(BP)
  694.     _GetPen
  695.     MOVE    Scratch-base(BP),D1
  696.     MOVE    WContRect+4-base(BP),D0    ; bottom coord of WContRect
  697.     SUB    #11,D0
  698.     CMP    D0,D1            ; is the position below the window
  699.     BLS.S    @0            ; no
  700.  
  701.     ; yes it is below the bottom of the window, so scroll up 11 pixels
  702.     CLR.L    -(A7)            ; Make room for a region handle.
  703.     _NewRgn                ; get handle into (A7)
  704.     PEA    WContRect-base(BP)    ; rect to scroll
  705.     CLR    -(A7)            ; no horiz.
  706.     MOVE    #$FFF5,-(A7)        ; 11 pix. vert.
  707.     MOVE.L    8(A7),-(A7)        ; push the region handle
  708.     _ScrollRect
  709.     _DisposRgn
  710.  
  711.     MOVE    WContRect+4-base(BP),D1    ; bottom coord of WContRect
  712.     SUBQ    #4,D1
  713.     BRA.S    @1
  714.  
  715.     @0: ADD    #11,D1            ; Add line height to pen location
  716.     @1:    MOVE    #1,-(A7)
  717.     MOVE    D1,-(A7)
  718.     _MoveTo
  719.  emitr:    RTS
  720.  
  721.  doDEL:    BSR.S    penh
  722.     CMP    #6,D1            ; first column?
  723.     blt.s    @0            ; don't beep anymore
  724.     SUB    #6,D1            ; back up
  725.     MOVE    D1,-(SP)
  726.     MOVE    Scratch-base(BP),-(SP)
  727.     _MoveTo
  728.     @0:    RTS
  729.  
  730.   penh:    PEA    Scratch-base(BP)
  731.     _GetPen
  732.     MOVE    Scratch+2-base(BP),D1
  733.     RTS
  734.  
  735.     DC.B    6,'EXP'            ; "expect" ( addr count -- )
  736.     DC.W    emit-theLink
  737. Expect:    MOVEM.L    D4/IS,-(SP)
  738.     JSR    swapp-base(BP)        ; leave number of chars on stack
  739.     MOVE    (PS)+,D0        ; addr
  740.     LEA    0(BP,D0.W),IS        ; set IS to the input address
  741.     CLR    Counter
  742.     MOVE    (PS)+,D4
  743.     @0:    JSR    key-base(BP)
  744.     MOVE    (PS)+,D5
  745.     CMPI    #CR,D5            ; if key = CR
  746.     BNE.S    @1
  747.     MOVE.B    #BL,0(IS,Counter)
  748.     CLR.B    1(IS,Counter)
  749.     MOVE.B    #BL,2(IS,Counter)
  750.     BRA.S    @3
  751.     @1:    CMPI    #BS,D5            ; if key = backspace
  752.     BNE.S    @2
  753.     TST    Counter            ; do nothing if first key is BS
  754.     BEQ.S    @0
  755.     SUBQ    #1,Counter        ; decriment counter
  756.     bSR.s    dodel    ; -base(BP)
  757.     JSR    space-base(BP)        ;    ... rubout char
  758.     bSR.s    dodel    ; -base(BP)
  759.     BRA.S    @0
  760.     @2:    MOVE.B    D5,0(IS,Counter)    ; stash the key into input buffer
  761.     ADDQ    #1,Counter
  762.     MOVE    D5,D0
  763.     JSR    emitcode-base(BP)
  764.     CMP    D4,Counter        ; is count=number of chars to get?
  765.     BNE.S    @0
  766.     @3:    JSR    docr-base(BP)
  767.     MOVEM.L    (SP)+,D4/IS
  768.     RTS
  769.  
  770.     DC.B    64+1,'0',0,0        ; "0" ( -- 0 )
  771.     DC.W    expect-theLink
  772. Zero:    CLR    -(PS)
  773.     RTS
  774.     
  775.     DC.B    64+4,'DRO'        ; "drop" ( n -- )
  776.     DC.W    zero-theLink
  777. drop:    ADDQ.L    #2,PS
  778.     RTS
  779.  
  780.     DC.B    4,'SWA'            ; "swap" ( n1 n2 -- n2 n1 )
  781.     DC.W    drop-theLink
  782. swapp:    MOVE.L    (PS)+,D0
  783.     SWAP    D0
  784.     MOVE.L    D0,-(PS)
  785.     RTS
  786.  
  787.     DC.B    64+5,'2DR'        ; "2drop" ( d -- )
  788.     DC.W    swapp-theLink
  789. TwoDrop:
  790.     ADDQ.L    #4,PS
  791.     RTS
  792.  
  793.     DC.B    4,'NUL'            ; "null" ( -- )
  794.     DC.W    twodrop-theLink
  795. Null:    RTS
  796.  
  797.     dc.b    4,'WAR'            ; "warm" ( ? -- )
  798.     dc.w    null-theLink        ; added 6/1/93
  799. WarmSt:    jmp    warm-base(bp)
  800.     
  801.     DC.B    6,'FOR'            ; "forget" ( -- ) forgets dictionary
  802.     DC.W    warmst-theLink
  803. Forget:    JSR    tick-base(BP)
  804.     MOVE    (PS)+,D0
  805.     MOVE    -2(BP,D0.W),Dict
  806.     LEA    -6(BP,D0.W),DP
  807.     RTS
  808.  
  809.     DC.B    8,'CON'            ; "constant" compile: ( n16 -- )
  810.     DC.W    forget-theLink    ;            runtime: ( -- n16 )
  811. Const:    JSR    token-base(BP)        ; make a header for the next token
  812.     JSR    header-base(BP)
  813.     JSR    marco-base(BP)        ; to return a constant
  814.     JSR    literal-base(BP)    ; compile time comma, runtime push
  815.     MOVE    #$4E75,(DP)+        ; compile  rts 
  816.     RTS
  817.  
  818.     DC.B    6,'CRE'            ; "create" compile: ( -- ) 
  819.     DC.W    const-theLink        ;          runtime: ( -- addr16 )
  820. Create:    JSR    token-base(BP)        ; give token this runtime action:
  821.     JSR    header-base(BP)
  822.     MOVE    #$3D3C,(DP)+        ;  • move     #nnnn,-(ps)
  823.     JSR    here-base(BP)
  824.     ADDQ    #6,(PS)
  825.     MOVE    (PS)+,(DP)+        ; supply the nnnn from above
  826.     MOVE    #$4EEB,(DP)+        ;  • jmp     null-base(bp)
  827.     MOVE.L    DP,DoesAddr-base(BP)    ; set DoesAddr to this "null"
  828.     MOVE    #null-base,(DP)+
  829.     RTS
  830.  
  831.     DC.B    5,'DOE'            ; "does>" ( -- ) (use after create)
  832.     DC.W    create-theLink        ;   set runtime action 
  833. Does:    MOVE.L    (RS)+,D0        ; pop the return address
  834.     SUB.L    BP,D0            ; convert to rel.addr
  835.     MOVE.L    DoesAddr-base(BP),A0    ; load jmp d(bp) address from create
  836.     MOVE    D0,(A0)            ; and stash rel.addr into it
  837.     RTS                ; returns same as ;
  838.  
  839.     DC.B    5,'ALL'            ; "allot" ( n16 -- )
  840.     DC.W    does-theLink        ;  compiles nada into the dictionary
  841. Allot:    ADDQ    #1,(PS)
  842.     ANDI    #$FFFE,(PS)        ; make it even!
  843.     ADDA    (PS)+,DP        ; increment the dictionary pointer
  844.     RTS
  845.  
  846.     DC.B    8,'VAR'            ; "variable" compile: ( -- )
  847.     DC.W    allot-theLink        ;            runtime: ( -- addr16 )
  848. Variable:
  849.     JSR    token-base(BP)        ; give token this runtime action:
  850.     JSR    header-base(BP)
  851.     JSR    marco-base(BP)        ; Sun May 1, 1988 04:24:44
  852.     MOVE    #$3D3C,(DP)+        ;  • move   #nnnn,-(ps)
  853.     JSR    here-base(BP)
  854.     ADDQ    #4,(PS)            ;    calculate nnnn
  855.     MOVE    (PS)+,(DP)+        ;  • (this is the nnnn)
  856.     MOVE    #$4E75,(DP)+        ;  • rts
  857.     ADDQ.L    #2,DP            ; 2 allot
  858.     RTS
  859.  
  860.     DC.B    3,'AE:'
  861.     DC.W    variable-theLink
  862. aColon:    MOVE    #AEvents-base,-(PS)
  863.     @0:    JSR    at-base(BP)
  864.     ADDI    #10,(PS)
  865.     MOVE    (PS),-(PS)
  866.     JSR    at-base(BP)
  867.     TST    (PS)+
  868.     BNE.S    @0
  869.     MOVE    (PS)+,D1
  870.     MOVE.L    A2,D0
  871.     SUB.L    BP,D0
  872.     MOVE    D0,0(BP,D1.W)
  873.     MOVE.L    (PS)+,(A2)+
  874.     MOVE.L    (PS)+,(A2)+
  875.     LEA    4(A2),A0
  876.     SUBA.L    A3,A0
  877.     MOVE    A0,(A2)+
  878.     CLR    (A2)+
  879.     MOVE    #$4EBA,(A2)+
  880.     MOVE    #aepre-base,-(PS)
  881.     JSR    back-base(BP)
  882.     JMP    rbrack-base(BP)
  883.  
  884.     DC.B    128+3,';AE'
  885.     DC.W    acolon-theLink
  886. semiae:    MOVE    #$4EAB,(A2)+        ; • jsr aepost(bp)
  887.     MOVE    #aepost-base,(A2)+    ; • rts
  888.     JMP    semi-base(BP)
  889.  
  890.     DC.B    64+5,'>NA'        ; ">name" ( 'addr -- name.addr )
  891.     DC.W    semiae-theLink
  892. toname:    SUBQ    #6,(PS)
  893.     RTS
  894.     
  895.     DC.B    64+5,'>LI'        ; ">link" ( 'addr -- link.addr )
  896.     DC.W    toname-theLink
  897. tolink:    SUBQ    #2,(PS)
  898.     RTS
  899.  
  900.     DC.B    3,'ID.'            ; "id." ( addr -- )
  901.     DC.W    tolink-theLink
  902. IDDot:    JSR    toname-base(BP)
  903.     MOVEA.L    DP,A0
  904.     MOVEQ.L    #5,D0
  905.     @0:    MOVE.L    #$C9C9C9C9,(A0)+    
  906.     DBRA    D0,@0
  907.     MOVE    (PS)+,D0
  908.     MOVE.L    0(BP,D0.W),(DP)
  909.     JSR    here-base(BP)
  910.     MOVE    (PS),-(PS)
  911.     JSR    cat-base(BP)
  912.     ANDI    #$1F,(PS)        ; look at 5 lsb's
  913.     ADDQ    #1,2(PS)
  914.     JSR    type-base(BP)
  915.     JMP    space-base(BP)
  916.     
  917.     DC.B    5,'WOR'            ; "words" ( -- ) list words
  918.     DC.W    iddot-theLink
  919. Words:    MOVE.L    D3,-(SP)        ; preserve register
  920.     MOVE    Dict,D3            ; start with the last word defined
  921.     @0:    MOVE    D3,-(PS)        ; push the name address
  922.     ADDQ    #6,(PS)            ; get the CFA
  923.     BSR.S    iddot            ; print the name
  924.      MOVE    4(BP,D3.W),D3        ; put the next name addr into D3
  925.     TST.B    1(BP,D3.W)        ; Quit if name is 0
  926.     BEQ.S    @1            ; do next word if not=0
  927.     JSR    qterm-base(BP)
  928.         TST    (PS)+
  929.     BEQ.S    @0
  930.     @1:    MOVE.L    (SP)+,D3        ; restore register
  931.     RTS
  932.     
  933.     DC.B    3,'PAD'            ; "pad" ( -- ) conversion pad
  934.     DC.W    words-theLink
  935. Pad:    JSR    here-base(BP)
  936.     ADDI    #40,(PS)        ; pad is 40 bytes from HERE.
  937.     RTS
  938.     
  939.     DC.B    4,'HOL'            ; "hold" ( c -- ) place c at ...
  940.     DC.W    pad-theLink        ; ... addr in Held.
  941. Hold:    SUBQ    #1,held-base(BP)
  942.     MOVE    held-base(BP),-(PS)
  943.     JMP    cstore-base(BP)
  944.     
  945.     DC.B    4,'SIG'            ; "sign" ( sf dval -- dval )
  946.     DC.W    hold-theLink
  947. Sign:    JSR    rote-base(BP)
  948.     TST    (PS)+
  949.     BGE.S    @0
  950.     MOVE    #'-',-(PS)
  951.     BSR.S    hold
  952.     @0:    RTS
  953.  
  954.     DC.B    4,'DAB'            ; "dabs" ( dval -- |dval| )
  955.     DC.W    sign-theLink
  956. Dabs:    TST    (PS)
  957.     BGE.S    @0
  958.     JSR    dneg-base(BP)
  959.     @0:    RTS
  960.  
  961.     DC.B    2,'<#',0        ; "<#" ( -- )
  962.     DC.W    dabs-theLink
  963. LSharp:    BSR.S    pad
  964.     MOVE    (PS)+,held-base(BP)
  965.     MOVEA.L    DP,A0
  966.     MOVE    #9,D0
  967.     @0:    CLR.L    (A0)+
  968.     DBRA    D0,@0
  969.     MOVE    #30,-(PS)
  970.     BRA.S    hold
  971.  
  972.     DC.B    2,'#>'.0        ; "#>" ( dval -- addr len )
  973.     DC.W    lsharp-theLink
  974. SharpG:    ADDQ.L    #2,PS
  975.     MOVE    held-base(BP),(PS)
  976.     BSR.S    pad
  977.     MOVE    2(PS),-(PS)        ; over
  978.     ADDQ    #1,(PS)
  979.     JMP    minus-base(BP)
  980.     
  981.     DC.B    1,'#',0,0        ; "#" ( dval -- d/base )
  982.     DC.W    sharpg-theLink
  983. Sharp:    MOVE    NBase-base(BP),-(PS)
  984.     JSR    msmod-base(BP)
  985.     JSR    rote-base(BP)
  986.     CMPI    #9,(PS)            ; is top of stack < 9?
  987.     BLE.S    @0
  988.     ADDQ    #7,(PS)
  989.     @0:    ADDI    #48,(PS)
  990.     JMP    hold-base(BP)
  991.  
  992.     DC.B    2,'#S',0        ; "#s" ( dval -- 0 0 )
  993.     DC.W    sharp-theLink
  994. Sharps:    BSR.S    sharp
  995.     TST.L    (PS)
  996.     BNE.S    sharps
  997.     RTS
  998.  
  999.     DC.B    2,'D.',0        ; "d." ( dval -- )
  1000.     DC.W    sharps-theLink
  1001. DDot:    JSR    swapp-base(BP)
  1002.     MOVE    2(PS),-(PS)
  1003.     JSR    dabs-base(BP)
  1004.     BSR.S    lsharp
  1005.     BSR.S    sharps
  1006.     JSR    sign-base(BP)
  1007.     BSR.S    sharpg
  1008.     jsr    type-base(BP)
  1009.     jmp    space-base(bp)
  1010.  
  1011.     DC.B    2,'U.',0        ; "u." ( uval -- )
  1012.     DC.W    ddot-theLink
  1013. UDot:    CLR    -(PS)
  1014.     BRA.S    ddot
  1015.  
  1016.     DC.B    3,'S>D'            ; "s>d" ( n -- d )
  1017.     DC.W    udot-theLink
  1018. SToD:    MOVE    (PS),-(PS)        ; dup
  1019.     JMP    zerolt-base(BP)        ; 0<
  1020.  
  1021.     DC.B    1,'.',0,0        ; "." ( n -- )
  1022.     DC.W    stod-theLink
  1023. Dot:    BSR.S    stod
  1024.     BRA.S    ddot
  1025.  
  1026.     DC.B    130,'."',0        ; "."" ( -- ) compiler part of (.")
  1027.     DC.W    dot-theLink
  1028. dotQ:    MOVE    #pQuote-base,-(PS)
  1029.     JSR    compile-base(BP)    ; compile a call to (.")
  1030.     JSR    here-base(BP)        ; ( -- addr )
  1031.     MOVE    #'"',-(PS)        ; ( -- addr 34 )
  1032.     JSR    word-base(BP)        ; ( -- addr )
  1033.     JSR    cat-base(BP)        ; ( -- count )
  1034.     ADDQ    #1,(PS)            ; ( -- count+1 )
  1035.     JMP    allot-base(BP)        ; enclose the string in dictionary
  1036.     
  1037.     DC.B    129,'(',0,0        ; "(" ( -- ) begin comment
  1038.     DC.W    dotq-theLink
  1039. Comment    CMPI.B    #41,(IS)+        ; read in characters until ")"
  1040.     BNE.S    Comment
  1041.     RTS
  1042.  
  1043.     DC.B    5,'CMO'            ; "cmove" ( addr1 addr2 len -- )
  1044.     DC.W    comment-theLink        ; from figFORTH, fixed 8/3/91
  1045. CMove:    MOVE    (PS)+,D0        ; D0 = length
  1046.     MOVE    (PS)+,D1
  1047.     LEA    0(BP,D1.W),A1        ; A1 = addr2
  1048.     MOVE    (PS)+,D1
  1049.     LEA    0(BP,D1.W),A0        ; A0 = addr1
  1050.     CMPA.L    A0,A1
  1051.     BPL.S    @2
  1052.  
  1053.     BRA.S    @1            ;  addr1 > addr2
  1054.     @0:    MOVE.B    (A0)+,(A1)+
  1055.     @1:    DBRA    D0,@0
  1056.     RTS
  1057.  
  1058.     @2:    ADDA    D0,A0            ;  addr1 ≤ addr2
  1059.     ADDA    D0,A1
  1060.     BRA.S    @4
  1061.     @3:    MOVE.B    -(A0),-(A1)
  1062.     @4:    DBRA    D0,@3
  1063.     RTS
  1064.     
  1065.     DC.B    4,'FIL'            ; "fill" ( addr count char -- )
  1066.     DC.W    cmove-theLink
  1067. Fill:    MOVE    (PS)+,D0        ; character
  1068.     MOVE    (PS)+,D1        ; count
  1069.     SUBQ    #1,D1            ; decrement count
  1070.     MOVE    (PS)+,A0        ; relative addr
  1071.     LEA    0(BP,A0.W),A0        ; get absolute addr
  1072.     @0:    MOVE.B    D0,0(A0,D1.W)        ; put char into addr + count
  1073.         DBRA    D1,@0            ; decrement count & loop until 0
  1074.     RTS
  1075.     
  1076.     DC.B    9,'-TR'            ; "-trailing"
  1077.     DC.W    fill-theLink        ;  ( addr count -- addr new.count )
  1078. dtrail:    MOVE    (PS)+,D1        ; get the count
  1079.     MOVE    (PS),D0            ; get the rel.addr
  1080.     LEA    0(BP,D0.W),A0        ; get the abs.addr
  1081.     @0:    CMPI.B    #$20,-1(A0,D1.W)    ; BEGIN  is char at addr+count $20
  1082.     DBNE    D1,@0            ; NOT UNTIL
  1083.     MOVE    D1,-(PS)        ; put new count on stack
  1084.     RTS
  1085.     
  1086.     DC.B    64+2,'1+',0        ; "1+" ( n -- n+1 )
  1087.     DC.W    dtrail-theLink
  1088. OnePl:    ADDQ    #1,(PS)
  1089.     RTS
  1090.  
  1091.     DC.B    64+2,'1-',0        ; "1-" ( n -- n-1 )
  1092.     DC.W    onepl-theLink
  1093. OneMi:    SUBQ    #1,(PS)
  1094.     RTS
  1095.     
  1096.     DC.B    64+2,'2+',0        ; "2+" ( n -- n+2 )
  1097.     DC.W    onemi-theLink
  1098. TwoPl:    ADDQ    #2,(PS)
  1099.     RTS
  1100.     
  1101.     DC.B    64+2,'2*',0        ; "2*" ( n -- n*2 )
  1102.     DC.W    twopl-theLink
  1103. ToStar:    ASL    (PS)
  1104.     RTS
  1105.  
  1106.     DC.B    64+2,'2/',0        ; "2/" ( n -- n/2 )
  1107.     DC.W    tostar-theLink
  1108. ToDiv:    ASR    (PS)
  1109.     RTS
  1110.     
  1111.     DC.B    5,'DEP'            ; "depth" ( -- n )
  1112.     DC.W    ToDiv-theLink        ; 16 bit entries on stack before this
  1113. depth:    move.l    szero-base(bp),d0
  1114.     sub.l    ps,d0
  1115.     move    d0,-(ps)
  1116.     bra.s    todiv
  1117.  
  1118.     DC.B    1,'@',0,0        ; "@" (at) ( addr16 -- n16 )
  1119.     DC.W    depth-theLink
  1120. At:    MOVE    (PS),D0            ; DANGER: odd values crash this
  1121.     MOVE    0(BP,D0.W),(PS)    
  1122.     RTS
  1123.  
  1124.     DC.B    1,'!',0,0        ; "!" (store) ( n16 addr16 -- )
  1125.     DC.W    at-theLink
  1126. Store:    MOVE    (PS)+,D0        ; DANGER: odd values crash this
  1127.     MOVE    (PS)+,0(BP,D0.W)
  1128.     RTS
  1129.  
  1130.     DC.B    2,'C!',0        ; "c!" (sea-store)( n8 addr16 -- )
  1131.     DC.W    store-theLink
  1132. CStore:    MOVE    (PS)+,D0        ; get the rel.addr (odd OK)
  1133.     ADDQ.L    #1,PS            ; align the stack
  1134.     MOVE.B    (PS)+,0(BP,D0.W)    ; put data at the addr
  1135.     RTS
  1136.  
  1137.     DC.B    2,'C@',0        ; "c@" (sea-at) ( addr16 -- n8 )
  1138.     DC.W    cstore-theLink
  1139. CAt:    MOVE    (PS),D0            ; get rel.addr (odd OK)
  1140.     CLR    (PS)            ; clear the result
  1141.     MOVE.B    0(BP,D0.W),1(PS)    ; stash the second byte
  1142.     RTS
  1143.  
  1144.     DC.B    64+2,'L@',0        ; "l@" (el-at) ( daddr32 -- n16 )
  1145.     DC.W    cat-theLink
  1146. LAt:    MOVEA.L    (PS)+,A0        ; get the double number "real" addr
  1147.     MOVE    (A0),-(PS)        ; fetch the contents
  1148.     RTS
  1149.  
  1150.     DC.B    64+2,'L!',0        ; "l!" (el-store)( n16 daddr32 -- )
  1151.     DC.W    lat-theLink
  1152. LStore:    MOVEA.L    (PS)+,A0
  1153.     MOVE    (PS)+,(A0)
  1154.     RTS
  1155.     
  1156.     DC.B    64+3,'DL@'        ; "dl@" ( daddr32 -- d32 )
  1157.     DC.W    lstore-theLink
  1158. DLAt:    MOVEA.L    (PS),A0
  1159.     MOVE.L    (A0),(PS)
  1160.     RTS
  1161.     
  1162.     DC.B    64+3,'DL!'        ; "dl!" ( d32 daddr32 -- )
  1163.     DC.W    dlat-theLink
  1164. DLStor:    MOVE.L    (PS)+,A0
  1165.     MOVE.L    (PS)+,(A0)
  1166.     RTS
  1167.  
  1168.     DC.B    2,'+!',0        ; "+!" ( n16 addr16 -- )
  1169.     DC.W    DLStor-theLink
  1170. pstore:    MOVE    (PS)+,D0
  1171.     MOVE    (PS)+,D1
  1172.     ADD    D1,0(BP,D0.W)
  1173.     RTS
  1174.     
  1175.     DC.B    64+4,'CBL'        ; "cblk" ( -- addr ) of fint
  1176.     DC.W    pstore-theLink
  1177. cBLK:    MOVE    #fint-base,-(PS)
  1178.     RTS
  1179.     
  1180.     DC.B    64+6,'CST'        ; "cstate" ( -- addr ) of fcolon
  1181.     DC.W    cblk-theLink
  1182. cState:    MOVE    #fcolon-base,-(PS)
  1183.     RTS
  1184.  
  1185.     DC.B    64+4,'BAS'        ; "base" ( -- addr )
  1186.     DC.W    cstate-theLink        ;   variable for the numeric radix
  1187. BaseA:    MOVE    #nbase-base,-(PS)
  1188.     RTS
  1189.  
  1190.     DC.B    64+3,'TIB'        ; "tib" ( -- addr )
  1191.     DC.W    basea-theLink        ;   variable for Terminal Input Buf.
  1192. TIB:    MOVE    #termbuf-base,-(PS)
  1193.     RTS
  1194.  
  1195.     DC.B    64+6,'LAT'        ; "latest" ( -- addr )
  1196.     DC.W    tib-theLink        ;   variable for the last dict word
  1197. Latest:    MOVE    Dict,-(PS)        ; push contents of the dict register
  1198.     RTS
  1199.  
  1200.     DC.B    64+3,'R0@'        ; "r0@" ( -- dabs.addr )
  1201.     DC.W    latest-theLink        ;   dabs.addr of r0
  1202. R0at:    MOVE.L    rzero-base(BP),-(PS)
  1203.     RTS
  1204.  
  1205.     DC.B    64+3,'RP@'        ; "rp@" ( -- dabs.addr )
  1206.     DC.W    r0at-theLink        ;   current addr of the return stack
  1207. RPat:    MOVE.L    RS,-(PS)
  1208.     RTS
  1209.  
  1210.     DC.B    64+3,'S0@'        ; "s0@" ( -- dabs.addr )
  1211.     DC.W    rpat-theLink        ;   dabs.addr of s0
  1212. S0at:    MOVE.L    szero-base(BP),-(PS)
  1213.     RTS
  1214.  
  1215.     DC.B    64+3,'SP@'        ; "sp@" ( -- dabs.addr )
  1216.     DC.W    s0at-theLink        ; address of the current stack cell
  1217. SPat:    MOVE.L    PS,-(PS)
  1218.     RTS
  1219.  
  1220.     DC.B    3,'HEX'            ; "hex" ( -- )
  1221.     DC.W    spat-theLink
  1222. hex:    MOVE    #$10,nbase-base(BP)
  1223.     RTS
  1224.  
  1225.     DC.B    7,'DEC'            ; "decimal" ( -- )
  1226.     DC.W    hex-theLink
  1227. decimal    MOVE    #10,nbase-base(BP)
  1228.     RTS
  1229.     
  1230.     DC.B    4,'?DU'            ; "?dup" ( n -- n n OR n [if n=0] )
  1231.     DC.W    decimal-theLink
  1232. qdup:    TST    (PS)
  1233.     BNE.S    dup
  1234.     RTS
  1235.  
  1236.     DC.B    64+3,'DUP'        ; "dup" ( n -- n n )
  1237.     DC.W    qdup-thelink
  1238. dup:    MOVE    (PS),-(PS)
  1239.     RTS
  1240.  
  1241.     DC.B    64+4,'OVE'        ; "over" ( n1 n2 -- n1 n2 n1 )
  1242.     DC.W    dup-theLink
  1243. over:    MOVE    2(PS),-(PS)
  1244.     RTS
  1245.  
  1246.     DC.B    3,'ROT'            ; "rot" ( n1 n2 n3 -- n2 n3 n1 )
  1247.     DC.W    over-theLink
  1248. rote:    MOVE.L    (PS)+,D0
  1249.     MOVE    (PS)+,D1
  1250.     MOVE.L    D0,-(PS)
  1251.     MOVE    D1,-(PS)
  1252.     RTS
  1253.  
  1254.     DC.B    64+4,'2DU'        ; "2dup" ( n1 n2 -- n1 n2 n1 n2 )
  1255.     DC.W    rote-theLink
  1256. todup:    MOVE.L    (PS),-(PS)
  1257.     RTS
  1258.  
  1259.     DC.B    5,'2SW'            ; "2swap"
  1260.     DC.W    todup-theLink        ;  ( n1 n2 n3 n4 -- n3 n4 n1 n2 )
  1261. toswap:    MOVE.L    (PS)+,D0
  1262.     MOVE.L    (PS)+,D1
  1263.     MOVE.L    D0,-(PS)
  1264.     MOVE.L    D1,-(PS)
  1265.     RTS
  1266.     
  1267.     DC.B    64+2,'>R',0        ; ">r" ( n -- ) rstack: ( -- n16 )
  1268.     DC.W    toswap-theLink
  1269. toR:    MOVE    (PS)+,-(RS)
  1270.     RTS
  1271.  
  1272.     DC.B    64+2,'R>',0        ; "r>" ( -- n ) rstack: ( n16 -- )
  1273.     DC.W    tor-theLink
  1274. Rfrom:    MOVE    (RS)+,-(PS)
  1275.     RTS
  1276.  
  1277.     DC.B    64+1,'R',0,0        ; "r" ( -- n ) rs: ( n16 -- n16 )
  1278.     DC.W    rfrom-theLink
  1279. Are:    MOVE    (RS),-(PS)
  1280.     RTS
  1281.  
  1282.     DC.B    4,'EXI'            ; "exit" ( -- ) drops return address
  1283.     DC.W    are-theLink
  1284. Exit:    ADDQ.L    #4,RS
  1285.     RTS
  1286.     
  1287.     DC.B    1,'*',0,0        ; "*" ( n1 n2 -- n1*n2 )
  1288.     DC.W    exit-theLink
  1289. times:    MOVE    (PS)+,D0
  1290.     MULS    (PS)+,D0
  1291.     MOVE    D0,-(PS)
  1292.     RTS
  1293.  
  1294.     DC.B    4,'/MO'            ; "/mod ( n1 n2 -- rem quot )
  1295.     DC.W    times-theLink
  1296. Smod:    MOVE    (PS)+,D0
  1297.     BNE.S    @0
  1298.     BRA.S    sfail
  1299.     @0:    MOVE    (PS)+,D1
  1300.     EXT.L    D1
  1301.     DIVS    D0,D1
  1302.     SWAP    D1
  1303.     MOVE.L    D1,-(PS)
  1304.     RTS
  1305.  
  1306.     DC.B    1,'/',0,0        ; "/" ( n1 n2 -- quotient )
  1307.     DC.W    smod-theLink
  1308. Slash:    bsr.s    smod
  1309.     JSR    swapp-base(BP)
  1310.     ADDQ.L    #2,PS
  1311.     RTS
  1312.  
  1313.     DC.B    3,'MOD'            ; "mod"    ( n1 n2 -- remainder )
  1314.     DC.W    slash-theLink
  1315. mod:    bsr.s    smod
  1316.     ADDQ.L    #2,PS
  1317.     RTS
  1318.  
  1319.     DC.B    2,'*/',0        ; "*/" ( n1 n2 n3 -- n1*n2/n3 )
  1320.     DC.W    mod-theLink
  1321. SSlash:    MOVE    (PS)+,D1
  1322.     BNE.S    sok
  1323.     ADDQ.L    #2,PS
  1324.  sfail:    MOVE    #-1,(PS)
  1325.     RTS
  1326.    sok:    MOVE    (PS)+,D0
  1327.     MULS    (PS),D0
  1328.     DIVS    D1,D0
  1329.     MOVE    D0,(PS)
  1330.     RTS
  1331.  
  1332.     DC.B    2,'U*',0        ; "u*" ( n1 n2 -- d32 )
  1333.     DC.W    sslash-theLink
  1334. UStar:    MOVE    (PS)+,D0
  1335.     MULU    (PS)+,D0
  1336.     MOVE.L    D0,-(PS)
  1337.     RTS
  1338.     
  1339.     DC.B    5,'M/M'            ; "m/mod" from King&Knight
  1340.     DC.W    ustar-theLink        ; ( num32 denom16 -- rem16 quot32 )
  1341. MSMod:    TST    (PS)            ; test for div by zero
  1342.     BNE.S    @0
  1343.     ADDQ.L    #4,PS
  1344.     BRA.S    sfail
  1345.     @0:    MOVE.L    D2,-(SP)        ; save D2
  1346.     MOVEQ    #0,D2            ; clear it
  1347.     MOVE    (PS)+,D2        ; pop denom into D2.W
  1348.     MOVE.L    (PS)+,D1        ; pop num into D1.L
  1349.     MOVE    D1,-(SP)        ; hold num.l on rstack
  1350.     CLR    D1
  1351.     SWAP    D1
  1352.     DIVU    D2,D1
  1353.     MOVE    D1,D0
  1354.     MOVE    (SP)+,D1
  1355.     DIVU    D2,D1
  1356.     SWAP    D1
  1357.     MOVE    D1,-(PS)        ; push remainder
  1358.     MOVE    D0,D1
  1359.     SWAP    D1
  1360.     MOVE.L    D1,-(PS)        ; push quotient
  1361.     MOVE.L    (SP)+,D2        ; restore register
  1362.     RTS
  1363.     
  1364.     DC.B    64+7,'DNE'        ; "dnegate" ( d32 -- -d32 )
  1365.     DC.W    msmod-theLink
  1366. DNeg:    NEG.L    (PS)
  1367.     RTS
  1368.     
  1369.     DC.B    64+2,'D+',0        ; "d+" ( d1 d2 -- d1+d2 )
  1370.     DC.W    dneg-theLink
  1371. DPlus:    MOVE.L    (PS)+,D0
  1372.     ADD.L    D0,(PS)
  1373.     RTS
  1374.     
  1375.     DC.B    128+2,'IF',0        ; "if" ( flag -- ) at runtime
  1376.     DC.W    dplus-theLink        ;      ( -- addr ) at compile time
  1377. pIf:    MOVE.L    #$4A5E6700,(DP)+    ; compile tst (ps)+  beq ...
  1378.   pi1:    bsr.s    pbegin
  1379.     ADDQ.L    #2,DP            ; make room for offset
  1380.     RTS
  1381.     
  1382.     DC.B    128+5,'WHI'        ; "while" ( flag -- ) at runtime
  1383.     DC.W    pif-theLink        ;    ( -- addr ) at compile time
  1384. pWhile:    BRA.S    pIf
  1385.     
  1386.     DC.B    128+4,'ELS'        ; "else" ( -- ) at runtime
  1387.     DC.W    pwhile-theLink        ; ( addr -- addr ) at compile time
  1388. pElse:    MOVE    #$6000,(DP)+
  1389.     bsr.s    pi1
  1390.     JSR    swapp-base(BP)
  1391.     BRA.S    pthen
  1392.  
  1393.     DC.B    128+4,'THE'        ; "then" ( -- ) at runtime
  1394.     DC.W    pelse-theLink        ;   ( addr -- ) at compile time
  1395. pThen:    bsr.s    pbegin
  1396.     MOVE    2(PS),-(PS)        ; over
  1397.     JSR    minus-base(BP)
  1398.     JSR    swapp-base(BP)
  1399.     JMP    store-base(BP)
  1400.  
  1401.     DC.B    128+6,'REP'        ; "repeat" ( -- ) at runtime
  1402.     DC.W    pthen-theLink        ; ( b.addr w.addr -- ) at c.time
  1403. pRepet:    MOVE    #$6000,(DP)+        ; compile bra ...
  1404.     JSR    swapp-base(BP)
  1405.     BSR.S    back
  1406.     BRA.S    pThen            ; HERE OVER - SWAP ! ;
  1407.  
  1408.     DC.B    128+5,'BEG'        ; "begin" ( -- ) at runtime
  1409.     DC.W    prepet-theLink        ;    ( -- addr ) at compile time
  1410. pBegin:    JMP    here-base(BP)
  1411.  
  1412.     DC.B    128+5,'UNT'        ; "until" ( flag -- ) at runtime
  1413.     DC.W    pbegin-theLink        ;      ( addr -- ) at compile time
  1414. pUntil    MOVE.L    #$4A5E6700,(DP)+    ; compile tst (ps)+  beq ...
  1415.     BRA.S    back
  1416.     
  1417.     DC.B    128+5,'AGA'        ; "again" ( -- ) at runtime
  1418.     DC.W    puntil-theLink        ;    ( addr -- ) at compile time
  1419. pAgain:    MOVE    #$6000,(DP)+        ; compile bra ...
  1420.     BRA.S    back
  1421.  
  1422.     DC.B    4,'BAC'            ; "back" ( addr -- )
  1423.     DC.W    pagain-theLink        ;  compile negative displacement
  1424. back:    bsr.s    pbegin
  1425.     JSR    minus-base(BP)
  1426.     MOVE    (PS),D0            ; get the target addr into d0
  1427.     BGE.S    @0
  1428.     NEG    D0            ; make it positive
  1429.     @0:    ANDI    #$FF80,D0        ; if > 1 byte
  1430.     BEQ.S    @1
  1431.     JMP    comma-base(BP)        ; then comma it as a long branch
  1432.     @1:    MOVE.B    1(PS),-1(DP)        ; else make it a short branch
  1433.     JMP    drop-base(BP)
  1434.  
  1435.     DC.B    128+2,'DO',0        ; "do" ( -- addr ) at compile time
  1436.     DC.W    back-theLink        ;  ( limit index -- ) at runtime
  1437. do:    MOVE    #$2F1E,(DP)+        ; • move.l (ps)+,-(ps)
  1438.     bra.s    pbegin
  1439.     
  1440.     DC.B    128+4,'LOO'        ; "loop" ( -- ) at runtime
  1441.     DC.W    do-theLink        ;   ( addr -- ) at compile time
  1442. Loop:    MOVE.L    #$52573017,(DP)+    ;  • addq #1,(rs)  (increment ix)
  1443.     MOVE.L    #$B06F0002,(DP)+    ;  • move (rs),d0  (get ix)
  1444.     MOVE    #$6B00,(DP)+        ;  • cmp  2(rs),d0 (check lim)
  1445.   pl:    BSR.S    back            ;  • bmi  ...      (loop if ix<lim)
  1446.     MOVE    #$588F,(DP)+        ; comma in the displacement to 'do'
  1447.     RTS                ;  • addq.l #4,rs    (drop ix&lim)
  1448.     
  1449.     DC.B    128+5,'+LO'        ; "+loop" ( n -- ) at runtime
  1450.     DC.W    loop-theLink        ;   ( addr -- ) at compile time
  1451. pLoop:    MOVE    #$4EAB,(DP)+
  1452.     MOVE    #ppl-base,(DP)+        ;  • jsr ppl-base(bp)
  1453.     MOVE    #$6700,(DP)+        ;  • beq  ...  (neg flag change)
  1454.     BRA.S    pl
  1455.  
  1456. ppl:    MOVE    4(A7),D0        ; get index
  1457.     CMP    6(A7),D0        ; check limit
  1458.     MOVE    SR,D1            ; hold result
  1459.     MOVE     (PS)+,D0        ; get step 
  1460.     ADD    D0,4(A7)        ; incerment index
  1461.     MOVE    4(A7),D0        ; get new index
  1462.     CMP    6(A7),D0        ; check new limit
  1463.     MOVE    SR,D0            ; hold it
  1464.     EOR    D0,D1            ; mix with last result
  1465.     AND    #8,D1            ; check for change in neg flag
  1466.     RTS
  1467.     
  1468.     DC.B    5,'LEA'            ; "leave" ( -- )
  1469.     DC.W    ploop-theLink        ;  set the index to the limit
  1470. Leave:    MOVE    6(RS),4(RS)
  1471.     RTS
  1472.  
  1473.     DC.B    2,'0<',0        ; "0<" ( n -- flag )
  1474.     DC.W    leave-theLink
  1475. ZeroLT:    TST    (PS)
  1476.     BLT.S    true
  1477.  false:    CLR    (PS)
  1478.     RTS
  1479.  true:    MOVE    #-1,(PS)
  1480.     RTS
  1481.  
  1482.     DC.B    2,'0>',0        ; "0>" ( n -- flag )
  1483.     DC.W    zerolt-theLink
  1484. ZeroGT:    NEG    (PS)
  1485.     BRA.S    zerolt
  1486.  
  1487.     DC.B    2,'0=',0        ; "0=" ( n -- flag )
  1488.     DC.W    zerogt-theLink
  1489. ZeroEQ:    TST    (PS)
  1490.     BEQ.S    true
  1491.     BRA.S    false
  1492.  
  1493.     DC.B    64+1,'+',0,0        ; "+" ( n1 n2 -- n1+n2 )
  1494.     DC.W    zeroeq-theLink
  1495. plus:    MOVE    (PS)+,D0
  1496.     ADD    D0,(PS)
  1497.     RTS
  1498.  
  1499.     DC.B    1,'-',0,0        ; "-" ( n1 n2 -- n1-n2 )
  1500.     DC.W    plus-theLink
  1501. minus:    NEG    (PS)
  1502.     bra.s    plus
  1503.  
  1504.     DC.B    1,'=',0,0        ; "=" ( n1 n2 -- flag )
  1505.     DC.W    minus-theLink
  1506. equal:    bsr.s    minus
  1507.     BRA.S    zeroeq
  1508.  
  1509.     DC.B    1,'<',0,0        ; "<" ( n1 n2 -- flag )
  1510.     DC.W    equal-theLink
  1511. lesst:    bsr.s    minus
  1512.     BRA.S    zerolt
  1513.  
  1514.     DC.B    1,'>',0,0        ; ">" ( n1 n2 -- flag )
  1515.     DC.W    lesst-theLink
  1516. moret:    bsr.s    minus
  1517.     BRA.S    zerogt
  1518.  
  1519.     DC.B    64+3,'AND'        ; "and"    ( n1 n2 -- n1(and)n2 )
  1520.     DC.W    moret-theLink
  1521. andd:    MOVE    (PS)+,D0
  1522.     AND    D0,(PS)
  1523.     RTS
  1524.  
  1525.     DC.B    64+2,'OR',0        ; "or" ( n1 n2 -- n1(or)n2 )
  1526.     DC.W    andd-theLink
  1527. orr:    MOVE    (PS)+,D0
  1528.     OR    D0,(PS)
  1529.     RTS
  1530.     
  1531.     DC.B    64+3,'XOR'        ; "xor" ( n1 n2 -- n1(xor)n2 )
  1532.     DC.W    orr-theLink
  1533. xor:    MOVE    (PS)+,D0
  1534.     EOR    D0,(PS)
  1535.     RTS
  1536.  
  1537.     DC.B    3,'ABS'            ; "abs"    ( n1 -- abs(n1) )
  1538.     DC.W    xor-theLink
  1539. abs:    TST    (PS)
  1540.     BGE.S    @0
  1541.     NEG    (PS)
  1542.     @0:    RTS
  1543.  
  1544.         DC.B    3,'MIN'            ; "min" ( n1 n2 -- n(min) )
  1545.     DC.W    abs-theLink
  1546. min:    MOVE    (PS)+,D0
  1547.     CMP    (PS),D0
  1548.     BLT.S    pd0
  1549.     RTS
  1550.    pd0:    MOVE    D0,(PS)
  1551.     RTS
  1552.  
  1553.         DC.B    3,'MAX'            ; "max" ( n1 n2 -- n(max) )
  1554.     DC.W    min-theLink
  1555. max:    MOVE    (PS)+,D0
  1556.     CMP    (PS),D0
  1557.     BGE.S    pd0
  1558.     RTS
  1559.  
  1560.     DC.B    2,'2@',0        ; "2@" ( addr -- d )
  1561.     DC.W    max-theLink        ; 32 bit fetch
  1562. TwoAt:    MOVE    (PS)+,D0
  1563.     MOVE.L    0(BP,D0.W),-(PS)
  1564.     RTS
  1565.  
  1566.     DC.B    2,'2!',0        ; "2!" ( d addr -- )
  1567.     DC.W    twoat-theLink        ; 32 bit store
  1568. TwoStore:
  1569.     MOVE    (PS)+,D0
  1570.     MOVE.L    (PS)+,0(BP,D0.W)
  1571.     RTS
  1572.  
  1573.     DC.B    9,'2CO'            ; "2constant"
  1574.     DC.W    twostore-theLink    ; defining: ( d -- )
  1575. TwoCon:    JSR    token-base(BP)        ; executing: ( -- d )
  1576.     JSR    header-base(BP)
  1577.     JSR    dlit-base(BP)
  1578.     MOVE    #$4E75,(DP)+
  1579.     RTS
  1580.  
  1581.     DC.B    9,'2VA'            ; "2variable"
  1582.     DC.W    twocon-theLink        ; defining: ( -- )
  1583. TwoVar:    JSR    variable-base(BP)    ; executing: ( -- addr )
  1584.     ADDQ.L    #2,DP
  1585.     RTS
  1586.  
  1587.     DC.B    64+3,'2>R'        ; "2>r" ( d -- ) rstack: ( -- d )
  1588.     DC.W    twovar-theLink
  1589. TwoToR:    MOVE.L    (PS)+,-(RS)
  1590.     RTS
  1591.  
  1592.     DC.B    64+3,'2R>'        ; "2r>" ( -- d ) rstack: ( d -- )
  1593.     DC.W    twotor-theLink
  1594. TwoRFrom:
  1595.     MOVE.L    (RS)+,-(PS)
  1596.     RTS
  1597.     
  1598.     DC.B    3,'A>R'            ; "a>r" ( addr -- )
  1599.     DC.W    tworfrom-theLink    ;   rstack: ( -- dabs.addr )
  1600. AToR:    JSR    toabs-base(BP)
  1601.     MOVE.L    (SP)+,A0
  1602.     MOVE.L    (PS)+,-(SP)
  1603.     JMP    (A0)
  1604.  
  1605.     DC.B    64+5,'2OV'        ; "2over" ( d1 d2 -- d1 d2 d1 )
  1606.     DC.W    ator-theLink
  1607. TwoOver:
  1608.     MOVE.L    4(PS),-(PS)
  1609.     RTS
  1610.  
  1611.     DC.B    4,'2RO'            ; "2rot" ( d1 d2 d3 -- d2 d3 d1 )
  1612.     DC.W    twoover-theLink
  1613. TwoRot:    MOVE.L    (PS)+,D0
  1614.     MOVE.L    (PS)+,D1
  1615.     MOVE.L    (PS),A0
  1616.     MOVE.L    D1,(PS)
  1617.     MOVE.L    D0,-(PS)
  1618.     MOVE.L    A0,-(PS)
  1619.     RTS
  1620.  
  1621. ; floating point stack manipulation
  1622.     DC.B    64+5,'FDR'        ; FDROP ( n1 n2 n3 n4 n5 -- )
  1623.     DC.W    tworot-theLink
  1624. fdrop:    ADDQ.L    #6,PS
  1625.     ADDQ.L    #4,PS
  1626.     RTS
  1627.  
  1628.     DC.B    4,'FDU'        ; FDUP ( n5 n4 n3 n2 n1 -- n5 n4 n3 n2 n1  n5 n4 n3 n2 n1 )
  1629.     DC.W    fdrop-theLink
  1630. fdup:    LEA    10(PS),A0
  1631.     MOVE.L    -(A0),-(PS)
  1632.     MOVE.L    -(A0),-(PS)
  1633.     MOVE.W    -(A0),-(PS)
  1634.     RTS
  1635.  
  1636.     DC.B    5,'FSW'            ; FSWAP ( f1 f2 -- f2 f1 )
  1637.     DC.W    fdup-theLink
  1638. fswap:    LEA    (PS),A0
  1639.     LEA    10(PS),A1
  1640.     MOVEQ    #4,D1
  1641.     @0:    MOVE    (A1),D0
  1642.     MOVE    (A0),(A1)+
  1643.     MOVE    D0,(A0)+
  1644.     DBRA    D1,@0
  1645.     RTS
  1646.  
  1647.     DC.B    5,'FPI'            ; FPICK ( fn..f1 m|n≥m≥1 -- fn..f1 fm )
  1648.     DC.W    fswap-theLink
  1649. fpick:    MOVE    #$0A,-(PS)
  1650.     JSR    times-base(BP)
  1651.     MOVE    (PS)+,D0
  1652.     LEA    0(PS,D0.W),A0
  1653.     MOVE.L    -(A0),-(PS)
  1654.     MOVE.L    -(A0),-(PS)
  1655.     MOVE    -(A0),-(PS)
  1656.     RTS
  1657.  
  1658.     DC.B    5,'FPA'        ; FPACK ( fn..f1 fnew m -- fn..f1 ) ( fm = fnew )
  1659.     DC.W    fpick-theLink
  1660. fpack:    MOVE    #$0A,-(PS)
  1661.     JSR    times-base(BP)
  1662.     MOVE    (PS)+,D0
  1663.     LEA    0(PS,D0.W),A0
  1664.     MOVE.L    (PS)+,(A0)+
  1665.     MOVE.L    (PS)+,(A0)+
  1666.     MOVE    (PS)+,(A0)+
  1667.     RTS
  1668.  
  1669.     DC.B    5,'FRO'        ; FROLL ( fn..f1 m -- fn..fm+1 fm-1..f1 fm )
  1670.     DC.W    fpack-theLink
  1671. froll:    bsr.s    fpick
  1672.     lsr.w    #1,d0
  1673.     subq    #1,d0
  1674.     @0:    MOVE    -(A0),10(A0)
  1675.     DBRA    D0,@0
  1676.     bsr.s    fswap
  1677.     JMP    fdrop-base(BP)
  1678.  
  1679. ; float - double number conversion
  1680.     DC.B    3,'D>F'            ; D>F ( d -- n1 n2 n3 n4 n5 )
  1681.     DC.W    froll-theLink
  1682. dtof:    MOVE.L    (PS)+,(DP)
  1683.     MOVE.L    DP,-(RS)
  1684.     SUBQ.L    #6,PS
  1685.     SUBQ.L    #4,PS
  1686.     PEA    (PS)
  1687.     FL2X
  1688.     RTS
  1689.  
  1690.     DC.B    3,'F>D'            ; F>D ( n1 n2 n3 n4 n5 -- d )
  1691.     DC.W    dtof-theLink
  1692. ftod:    PEA    (PS)
  1693.     MOVE.L    DP,-(RS)
  1694.     FX2L
  1695.     JSR    fdrop-base(BP)  
  1696.     MOVE.L    (DP),-(PS)
  1697.     RTS
  1698.  
  1699.     DC.B    2,'F@',0        ; F@ ( addr -- n5 n4 n3 n2 n1 )
  1700.     DC.W    ftod-theLink
  1701. fat:    MOVE    (PS)+,D0
  1702.     LEA    10(BP,D0.W),A0
  1703.     MOVE.L    -(A0),-(PS)
  1704.     MOVE.L    -(A0),-(PS)
  1705.     MOVE    -(A0),-(PS)
  1706.     RTS
  1707.  
  1708.     DC.B    2,'F!',0        ; F! ( n5 n4 n3 n2 n1 addr -- )
  1709.     DC.W    fat-theLink
  1710. fstore:    MOVE    (PS)+,D0
  1711.     LEA    0(BP,D0.W),A0
  1712.     MOVE.L    (PS)+,(A0)+
  1713.     MOVE.L    (PS)+,(A0)+
  1714.     MOVE    (PS)+,(A0)
  1715.     RTS
  1716.  
  1717.     DC.B    2,'F,',0        ; F, ( n5 n4 n3 n2 n1 -- )
  1718.     DC.W    fstore-theLink
  1719. fcomma:    MOVE.L    (PS)+,(DP)+
  1720.     MOVE.L    (PS)+,(DP)+
  1721.     MOVE    (PS)+,(DP)+
  1722.     RTS
  1723.  
  1724.     DC.B    9,'FCO'        ; FCONSTANT ( comp: f -- ) ( run: -- f )
  1725.     DC.W    fcomma-theLink
  1726. fcon:    JSR    create-base(BP)
  1727.     BSR.S    fcomma
  1728.     JSR    does-base(BP)
  1729.     BRA.S    fat
  1730.  
  1731.     DC.B    9,'FVA'        ; FVARIABLE ( compile: -- ) ( run: -- addr )
  1732.     DC.W    fcon-theLink
  1733. fvar:    JSR    variable-base(BP)
  1734.     ADDQ.L #8,DP
  1735.     RTS
  1736.  
  1737.     DC.B    3,'SCI'            ; SCI ( decimal.places -- )
  1738.     DC.W    fvar-theLink
  1739. sci:    CLR    -(PS)
  1740.   sci1:    MOVE.L    (PS)+,form-base(BP)
  1741.     RTS
  1742.  
  1743.     DC.B    3,'FIX'            ; FIX ( decimal.places -- )
  1744.     DC.W    sci-theLink
  1745. fix:    MOVE    #$FFFF,-(PS)
  1746.     BRA.S    sci1
  1747.  
  1748.     DC.B    2,'F.',0        ; F. ( n5 n4 n3 n2 n1 -- )
  1749.     DC.W    fix-theLink
  1750. fdot:    PEA    form-base(BP)
  1751.     PEA    (PS)
  1752.     PEA    $14(DP)
  1753.     FX2DEC
  1754.     JSR    fdrop-base(BP)
  1755.     PEA    form-base(BP)
  1756.     PEA    $14(DP)
  1757.     MOVE.L    A2,-(RS)
  1758.     FDEC2STR
  1759.   dwrd:    JSR    here-base(BP)
  1760.     JSR    count-base(BP)
  1761.     JSR    type-base(BP)
  1762.     JMP    space-base(BP)
  1763.  
  1764.     DC.B    8,'FCO'        ; FCOMPARE ( f1 f2 -- f1 f2 [flag: -1|f1<f2 0|f1=f2 1|f1>f2] )
  1765.     DC.W    fdot-theLink
  1766. fcomp:    MOVE    #1,-(PS)
  1767.     PEA    2(PS)
  1768.     PEA    12(PS)
  1769.     FCMPX
  1770.     BGE.S    @0
  1771.     NEG    (PS)
  1772.     RTS
  1773.     @0:    BNE.S    @1
  1774.     CLR    (PS)
  1775.     @1:    RTS
  1776.  
  1777.     DC.B    2,'F+',0        ; F+ ( f1 f2 -- f1+f2 )
  1778.     DC.W    fcomp-theLink
  1779. fplus:    PEA    (PS)
  1780.     PEA    10(PS)
  1781.     FADDX
  1782.   fd1:    JMP    fdrop-base(BP)
  1783.  
  1784.     DC.B    2,'F-',0        ; F- ( f1 f2 -- f1-f2 )
  1785.     DC.W    fplus-theLink
  1786. fminus:    PEA    (PS)
  1787.     PEA    10(PS)
  1788.     FSUBX
  1789.     BRA.S    fd1
  1790.  
  1791.     DC.B    2,'F*',0        ; F* ( f1 f2 -- f1*f2 )
  1792.     DC.W    fminus-theLink
  1793. fstar:    PEA    (PS)
  1794.     PEA    10(PS)
  1795.     FMULX
  1796.     BRA.S    fd1
  1797.  
  1798.     DC.B    2,'F/',0        ; F/ ( f1 f2 -- f1/f2 )
  1799.     DC.W    fstar-theLink
  1800. fslash:    PEA    (PS)
  1801.     PEA    10(PS)
  1802.     FDIVX
  1803.     BRA.S    fd1
  1804.  
  1805.     DC.B    4,'FRE'            ; FREM ( f1 f2 -- rem[f1/f2] )
  1806.     DC.W    fslash-theLink
  1807. frem:    PEA    (PS)
  1808.     PEA    10(PS)
  1809.     FREMX
  1810.     BRA.S    fd1
  1811.  
  1812.     DC.B    2,'F^',0        ; F^ ( f1 f2 -- f1^f2 )
  1813.     DC.W    frem-theLink
  1814. ftothe:    PEA    (PS)
  1815.     PEA    10(PS)
  1816.     FXPWRY
  1817.     BRA.S    fd1
  1818.  
  1819.     DC.B    4,'FIN'            ; FINT ( f -- int[f] )
  1820.     DC.W    ftothe-theLink
  1821. finte:    PEA    (PS)
  1822.     FTINTX
  1823.     RTS
  1824.  
  1825.     DC.B    4,'FAB'            ; FABS ( f -- |f| )
  1826.     DC.W    finte -theLink
  1827. fabs:    PEA    (PS)
  1828.     FABSX
  1829.     RTS
  1830.  
  1831.     DC.B    5,'FSQ'            ; FSQRT ( f -- sqrt[f] )
  1832.     DC.W    fabs-theLink
  1833. fsqrt:    PEA    (PS)
  1834.     FSQRTX
  1835.     RTS
  1836.  
  1837.     DC.B    4,'FSI'            ; FSIN ( f -- sin[f] )
  1838.     DC.W    fsqrt-theLink
  1839. fsin:    PEA    (PS)
  1840.     FSINX
  1841.     RTS
  1842.  
  1843.     DC.B    4,'FCO'            ; FCOS ( f -- cos[f] )
  1844.     DC.W    fsin-theLink
  1845. fcos:    PEA    (PS)
  1846.     FCOSX
  1847.     RTS
  1848.  
  1849.     DC.B    4,'FTA'            ; FTAN ( f -- tan[f] )
  1850.     DC.W    fcos-theLink
  1851. ftan:    PEA    (PS)
  1852.     FTANX
  1853.     RTS
  1854.  
  1855.     DC.B    4,'FAT'            ; FATN ( f -- atn[f] )
  1856.     DC.W    ftan-theLink
  1857. fatn:    PEA    (PS)
  1858.     FATNX
  1859.     RTS
  1860.  
  1861.     DC.B    4,'FEX'            ; FEXP ( f1 -- e^f1 )
  1862.     DC.W    fatn-theLink
  1863. fexp:    PEA    (PS)
  1864.     FEXPX
  1865.     RTS
  1866.  
  1867.     DC.B    3,'FLN'            ; FLN ( f1 -- ln[f1] )
  1868.     DC.W    fexp-theLink
  1869. fln:    PEA    (PS)
  1870.     FLNX
  1871.     RTS
  1872.  
  1873.     DC.B    4,'@PE'            ; "@pen" ( -- h v )
  1874.     DC.W    fln-theLink
  1875. AtPen:    PEA    (DP)
  1876.     _GetPen
  1877.     MOVE.L    (DP),-(PS)
  1878.     RTS
  1879.  
  1880.     DC.B    64+4,'!PE'        ; "!pen" ( h v -- )
  1881.     DC.W    atpen-theLink
  1882. SetPen:    MOVE.L    (PS)+,-(SP)
  1883.     _MoveTo
  1884.     RTS
  1885.  
  1886.     DC.B    64+3,'-TO'        ; "-to" ( h v -- )
  1887.     DC.W    setpen-theLink
  1888. LineTo:    MOVE.L    (PS)+,-(SP)
  1889.     _LineTo
  1890.     RTS
  1891.  
  1892.     DC.B    64+5,'PMO'        ; "pmode" ( mode -- )
  1893.     DC.W    lineto-theLink
  1894. PMode:    MOVE    (PS)+,-(SP)
  1895.     _PenMode
  1896.     RTS
  1897.  
  1898.     DC.B    6,'@MO'            ; "@mouse" ( -- h v )
  1899.     DC.W    pmode-theLink
  1900. AtMouse:
  1901.     SUBQ.L    #4,PS
  1902.     PEA    (PS)
  1903.     _GetMouse
  1904.     RTS
  1905.  
  1906.     DC.B    4,'TAS'            ; "task" ( -- ) a no-op word
  1907.     DC.W    AtMouse-theLink        ;  use:  forget task : task ;
  1908. Task:    RTS                ;  to cleanup dictionary
  1909. DictEnd:
  1910.